COMMENT ⊗   VALID 00009 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	entry begin comment The output module of TEX.
C00004 00003	Routines for time of day and file information (highly system-dependent)
C00009 00004	initialization: initout,declareofil
C00016 00005	Output codes for Press.
C00030 00006	General description of the shipout procedure.
C00037 00007	The recursive traversal procedures: vlistout,hlistout
C00048 00008	internal procedure shipout(integer p) # the main output procedure,produces one page
C00051 00009	internal procedure closeout # just before TEX stops, do this
C00056 ENDMK
C⊗;
entry; begin comment The output module of TEX.

Modified by D. Wyatt and Leo Guibas to produce Press files for PARC.
Modified by Lyle Ramshaw to use SAIL-style I/O, and thus become
	the standard output module for the Press-producing TEX.

(It is wise to read the box data structure definitions in TEXSEM
before going very deeply into the following code.)

Each TEXOUT module is supposed to include the following procedures
invoked by the main program:

	initout			gets the output module started initially
	declareofil(string s) called when the output file name is known
	shipout(integer p)	called for each nonempty page to be output
	closeout		finishes the output
;

require "TEXHDR.SAI" source_file;
require "
	Note: This output module prepares Press files only. " message;

comment Routines for time of day and file information (highly system-dependent);
integer octaltime # the machine's one word date/time stamp, in whatever
	format the OS specifies (set by initout);

IFSUAI
comment These routines are due to Hans Moravec;

string procedure daytime;
begin comment returns octaltime down to the second, as a string;
integer d,t,sw,sd; string s;
	string procedure cvs2(integer i);
	return((((i div 10) mod 10)+"0")&((i mod 10)+"0"));
t←octaltime land '777777; d←octaltime lsh -18;
getformat(sw,sd); setformat(0,7);
s←cvs((d mod 31)+1)&", "&cvs((d div 31)div 12 + 1964);
setformat(sw,sd);
return((case ((d div 31) mod 12) of
	("January","February","March","April","May","June",
	"July","August","September","October","November","December"))&" "&
	s&"    "&cvs2(t div (60*60))&":"&
	cvs2((t div 60) mod 60)&":"&cvs2(t mod 60));
end;

comment Press file format demands that we supply a machine date/time
stamp in Alto-Pup format, and the user's name as a string;

integer procedure altotime;
comment Returns the number of seconds since midnight, Jan. 1, 1901 GMT;
begin integer stdtime # seconds since midnight, Pacific standard time;
integer days # days since Jan. 1, 1964;
stdtime←call(0,"STDTIM") land '777777;
days←call(0,"DAYCNT");
return(((23010+days)*24+8)*3600+stdtime);
end;

string procedure username;
comment Returns the name of the logged-in user as a SAIL string;
begin string prg, name, nxtprg, nxtnam;
integer namfil, brchar, eof, lftabbreak, ppn, i, j;
ppn←call(0,"GETPPN") # ppn is in 6-bit format;
prg←"" # null characters in prg would hurt, so can't use CVXSTR;
for i←-12 step 6 until 0 do if (j←(ppn lsh i) land '77) then prg←prg&(j+'40);
setbreak(lftabbreak←getbreak,'12&'11,'15&'15,"ISN");
open(namfil←getchan,"DSK",0,2,0,150,brchar,eof);
lookup(namfil,"FACT.TXT[SPL,SYS]", eof);
name←prg&" @ SAIL" # this is used for new accounts not yet in the FACT file;
brchar←'12; comment we don't need to check brchar below if FACT is good;
while not eof do
	begin if brchar='12 then nxtprg←input(namfil,lftabbreak);
	if brchar='11 then nxtnam←input(namfil,lftabbreak);
	if equ(prg,nxtprg) then
		begin name←nxtnam; done;
		end;
	end;
release(namfil);
relbreak(lftabbreak);
return(name);
end;

ENDSUAI

IFTENEX
string procedure daytime # translate octaltime into a string;
begin return(odtim(octaltime,'036000000000)) end;

integer procedure altotime # translate octaltime into a Alto-format time;
begin
 return(((octaltime lsh -18)-15385)*(3600*24)+(octaltime land '777777));
end;

string procedure username;
begin  integer logdir,condir,ttyno;
	gjinf(logdir,condir,ttyno);
	return(dirst(logdir));
end;
ENDTENEX

ifc not (SUAI or TENEX) thenc
	require "Three new procedures have to be written!" message;
	FIXTHIS write the following procedures:
		daytime  (convert octaltime to a string)
		altotime  (convert octaltime to a Alto-format time)
		username  (return user's name as a string);
endc
 
comment initialization: initout,declareofil;

internal string ofilext # filename extension for output;
internal string deviceext # extension to use in font information files;
internal string ofilname # output file name, set by first \input;
internal string libraryarea # default system area for fonts;
integer ochan # output channel number;
boolean no_output_yet # no pages shipped out yet;
integer recnum # current record number;

define maxparts=400;
saf integer array partdir[0:2*maxparts];
integer pdptr, nparts # byte pointer into partdir, number of parts;

saf boolean array fontused[0:nfonts-1] # has the font actually been used?;

define micasPerInch=⊂2540⊃;
define inchesPerPoint=⊂0.013837⊃;
define pointsPerInch=⊂(1/inchesPerPoint)⊃;
define conv=⊂(rfudge*(micasPerInch*inchesPerPoint/1000))⊃;
define roundup(x)=⊂conv*(x)+.999999⊃ # integer←roundup(x) gives ceiling(x);
define pageheight=11*micasPerInch, pagewidth=8.5*micasPerInch;

IFPARC
external boolean color;
external integer curbrightness,curhue,cursaturation;
define brightness=0, hue=1, saturation=2;
ENDPARC

comment Next we have some procedures to implement byte-oriented I/O
	using SAIL's I/O primitives;
integer nextword # holds bytes that form part of the next word to be output;
integer bytecount # number of bytes already output on ochan;

simp procedure Bout(integer byte);
	begin comment output an 8-bit byte to ochan;
	case (bytecount mod 4) of
	    begin
	    [0] nextword←byte lsh 28;
	    [1] nextword←nextword lor ((byte land '377) lsh 20);
	    [2] nextword←nextword lor ((byte land '377) lsh 12);
	    [3] wordout(ochan, nextword lor ((byte land '377) lsh 4));
	    else confusion
	    end;
	bytecount←bytecount+1;
	end;

simp procedure Wout(integer word);
	begin comment output a 16-bit word to ochan;
	case (bytecount mod 4) of
	    begin
	    [0] nextword←word lsh 20;
	    [2] wordout(ochan,nextword lor ((word land '177777) lsh 4));
	    else confusion comment must be at 16-bit-word boundary;
	    end;
	bytecount←bytecount+2;
	end;

simp procedure Dout(integer word);
	begin
	Wout(word lsh -16); Wout(word);
	end;

simp procedure DoutAligned(integer word);
	begin comment Hacked version of Dout:  file must be at a double
		word boundary, and the argument word is NOT shifted;
DEBUGONLY if (bytecount mod 4)≠0 then confusion;
	wordout(ochan,word);
	bytecount←bytecount+4;
	end;

simp procedure Sout(reference integer first; integer numbytes);
	begin comment output a string of 8-bit bytes: the output file
		must start out and end 32-bit-word aligned!;
	integer numwords;
DEBUGONLY if (bytecount mod 4)≠0 then confusion;
DEBUGONLY if (numbytes mod 4)≠0 then confusion;
	numwords←numbytes div 4;
	arryout(ochan,first,numwords);
	bytecount←bytecount+numbytes;	
	end;

simp integer procedure PadRecord(integer padval);
	begin
	integer padlength, i, paddingword;
	padlength←-(bytecount mod 512);
	if padlength<0 then padlength←padlength+512;
	for i←1 thru (padlength mod 4) do Bout(padval);
	paddingword←(padval lsh 8) lor padval;
	paddingword←(paddingword lsh 16) lor paddingword;
	paddingword←paddingword lsh 4;
	for i←1 thru (padlength div 4) do DoutAligned(paddingword);
	return(padlength);
	end;

simp procedure iBCPLout(integer findex; integer maxbytes);
	begin integer i,bp;
	bp←point(8,fpfi[findex,1],-1);
	for i←0 thru maxbytes-1 do Bout(ildb(bp));
	end;

simp procedure sBCPLout(string s; integer maxbytes);
	begin
	integer len, i;
	len←(maxbytes-1) min length(s);
	Bout(len);
	for i←1 thru maxbytes-1 do
		if i<=len then Bout(s[i to i]) else Bout(0);
	end;

comment Output codes for Press.


comment Press Entity list commands;
define
	ELShowCharactersShort = '0,
	ELSetSpaceXShort = '140,
	ELFont = '160,
	ELSetX = '356,
	ELSetY = '357,
	ELShowCharacters = '360,
	ELSetSpaceX = '364,
	ELResetSpace = '366,
	ELShowRectangle = '376,
	ELNop = '377,
	ELSkipCharactersShort = '40,
	ELSetBrightness = '370,
	ELSetHue = '371,
	ELSetSaturation = '372;

comment our Press file will have four entities per page:  at sixteen
	fonts per entity (one font set), this allows up to 64 fontsa;

short integer en # current entity (0,1,2, or 3);
define d0max=8000, e0max=12000, d1max=8000, e1max=12000;
define d2max=8000, e2max=12000, d3max=8000, e3max=12000;
define d0len=d0max div 4, d1len=d1max div 4;
define d2len=d2max div 4, d3len=d3max div 4;
define e0len=e0max div 4, e1len=e1max div 4;
define e2len=e2max div 4, e3len=e3max div 4;
saf integer array dl0[0:d0len];
saf integer array el0[0:e0len];
saf integer array dl1[0:d1len];
saf integer array el1[0:e1len];
saf integer array dl2[0:d2len];
saf integer array el2[0:e2len];
saf integer array dl3[0:d3len];
saf integer array el3[0:e3len];
saf integer array dlp[0:3] # data list pointers;
saf integer array elp[0:3] # entity list pointers;
IFPARC
saf integer array eightbitflag[0:3] # set to '200 for eightbit fonts;
ENDPARC
preload_with d0max,d1max,d2max,d3max;
saf integer array dmax[0:3] # max permissible data list count (bytes);
preload_with e0max,e1max,e2max,e3max;
saf integer array emax[0:3] # max permissible entity list count (bytes);
DEBUGONLY integer array dlmaxused[0:3] # max attained data list count (bytes);
DEBUGONLY integer array elmaxused[0:3] # max attained entity list count (bytes);
saf integer array dct[0:3] # current data list count (bytes);
saf integer array ect[0:3] # current entity list count (bytes);
saf integer array lsc[0:3] # data list count of previous ShowChars;
saf integer array cx[0:3] # current x position;
saf integer array cy[0:3] # current y position;
saf integer array cf[0:3] # current font;
ifc nfonts≠64 thenc 
  require "TexPrs currently assumes that nfonts is 64:" message;
  require "   4 entities with one font set (= 16 fonts) for each!" message;
endc
define fontset(f)=⊂(f land '3)⊃ # right-most two bits are font set;
define fontnum(f)=⊂(f lsh -2)⊃ # the other four bits are font within set;
comment Procedures for dealing with DL and EL;

simp procedure StartPage;
	begin
	integer i;
	comment initialize byte pointers into DL and EL;
	dlp[0]←point(8, dl0[0], -1);
	dlp[1]←point(8, dl1[0], -1);
	dlp[2]←point(8, dl2[0], -1);
	dlp[3]←point(8, dl3[0], -1);
	elp[0]←point(8, el0[0], -1);
	elp[1]←point(8, el1[0], -1);
	elp[2]←point(8, el2[0], -1);
	elp[3]←point(8, el3[0], -1);
	for i←0 step 1 until 3 do
	  begin dct[i]←0; ect[i]←0; lsc[i]←0; cx[i]←0; cy[i]←0; cf[i]←0;
	   IFPARC eightbitflag[i]←if fpfb[i]<0 then '200 else 0; ENDPARC
	  end;
	en←0;
IFPARC	if color then
		begin
		if curbrightness ≠ 0 then SetBrightness(curbrightness);
		if curhue ≠ 0 then SetHue(curhue);
		if cursaturation ≠ 0 then SetSaturation(cursaturation);
		end; ENDPARC
	end;

simp procedure ELByte (integer b);
	begin
	if ect[en]≥emax[en] then overflow(emax[en]);
	idpb(b, elp[en]);
	ect[en]←ect[en]+1;
	end;

simp procedure ELWord (integer w);
	begin ELByte(w lsh -8); ELByte(w) end;

simp procedure ELDWord (integer d);
	begin ELWord(d lsh -16); ELWord(d) end;

simp procedure DLByte (integer b);
	begin
	if dct[en]≥dmax[en] then overflow(dmax[en]);
	idpb(b, dlp[en]);
	dct[en]←dct[en]+1;
	end;

simp procedure AddPart(integer parttype, beginrec, nrecs, pad(0));
	begin
	if nparts≥maxparts then overflow(nparts);
	idpb(parttype, pdptr);
	idpb(beginrec, pdptr);
	idpb(nrecs, pdptr);
	idpb(pad, pdptr);
	nparts←nparts+1;
	end;

simp procedure Flush;
	begin
	short integer k,n;
	n←dct[en]; k←n-lsc[en];
	if k>0 then
		begin integer i;
		if k≤32 then ELByte(ELShowCharactersShort+k-1)
		else	begin
			for i←1 thru (k div 255) do 
			  begin ELByte(ELShowCharacters); ELByte(255); end;
			ELByte(ELShowCharacters); ELByte(k mod 255); 
			end;
		lsc[en]←n;
		end;
	end;

simp procedure FlushAll;
	begin integer sen,i;
	sen←en;
	for i←0 thru 3 do
		begin
		en←i;
		Flush;
		end;
	en←sen;
	end;

simp procedure SetX(integer x);
	begin
	Flush; ELByte(ELSetX); ELWord(cx[en]←x);
	end;

simp procedure SetY(integer y);
	begin
	y←pageheight-y # invert y direction;
	comment note the assumption that ShowCharacters doesn't change y;
	if y≠cy[en] then
		begin Flush; ELByte(ELSetY); ELWord(cy[en]←y); end;
	end;

IFPARC
internal simp procedure SetBrightness(integer b);
	begin integer sen, i;
	FlushAll;
	sen←en;
	for i←0 thru 3 do
		begin
		en←i;
		ELByte(ELSetBrightness);
		ELByte(b);
		end;
	en←sen;
	end;

internal simp procedure SetHue(integer h);
	begin integer sen, i;
	FlushAll;
	sen←en;
	for i←0 thru 3 do
		begin
		en←i;
		ELByte(ELSetHue);
		ELByte(h);
		end;
	en←sen;
	end;

internal simp procedure SetSaturation(integer s);
	begin integer sen, i;
	FlushAll;
	sen←en;
	for i←0 thru 3 do
		begin
		en←i;
		ELByte(ELSetSaturation);
		ELByte(s);
		end;
	en←sen;
	end;

internal simp procedure PutColor(integer clrcmd,clrval);
case clrcmd of begin
[hue] SetHue(clrval);
[saturation] SetSaturation(clrval);
[brightness] SetBrightness(clrval);
else comment do nothing;
  end;
ENDPARC

simp procedure PutRectangle(integer x0,y0,h,w);
if h>0 and w>0 then
	begin comment x0,y0 specify the upper left corner;
	en←3 # put all rectangles in entity 3;
	Flush;
	SetX(x0); SetY(y0+h);
	ELByte(ELShowRectangle); ELWord(w); ELWord(h);
	end;

simp procedure SetFont(integer f);
	begin
	integer t;
	comment switch entities if necessary;
	en←fontset(f) # the 64 fonts are interleaved into four font sets;
	t←fontnum(f) # font number in font set;
	if cf[en]≠t then begin Flush; ELByte(ELFont+(cf[en]←t));
		IFPARC
		eightbitflag[en]←if fpfb[f]<0 then '200 else 0;
		ENDPARC end;
	end;

comment append a trailer to entity list n;
simp procedure ETrailer(integer n, beginbyte, bytelength);
	begin
	en←n;
	if ect[en]=0 then return # empty entity - leave it empty;
	if (ect[en] mod 2) ≠ 0 then ELByte(ELNop) # pad to word boundary;
	if (ect[en] mod 4) ≠ 0 then
	   begin ELByte(ELNop); ELByte(ELNop) end # pad to DWord boundary;
	ELByte(125) # type;
	ELByte(en) # font set;
	ELDWord(beginbyte) # beginning of DL region;
	ELDWord(bytelength) # length of DL region;
	ELWord(0); ELWord(0) # origin (Xe, Ye);
	ELWord(0); ELWord(0) # bottom left corner of bounding box;
	ELWord(pagewidth); ELWord(pageheight) # dimensions of bounding box;
	ELWord(ect[en] div 2+1) # entity length in WORDS (including this number);
	comment Assertion: the entity now contains a multiple of four bytes;
	end;

define outchar(c)=⊂DLByte(((c)land '177) IFPARC +eightbitflag[en] ENDPARC)⊃ #
	macro for output of a single character;
define outrule(x0,y0,h,w)=⊂PutRectangle(x0,y0,h,w)⊃;
define newfont(f)=⊂SetFont(f)⊃;
define setpos(x0,y0)=⊂SetY(y0); SetX(x0)⊃;


internal procedure initout # get TEXOUT started properly;
begin integer i;
ofilname←null;
deviceext←".TFM";
IFTENEX ofilext←".PRESS"; libraryarea←"<TEX>"; ENDTENEX
IFSUAI ofilext←".press"; libraryarea←"[TEX,SYS]"; ENDSUAI
IFMIT ofilext←"PRE"; libraryarea←"TEXFNT;"; ENDMIT
IFTOPS10 ofilext←"PRE"; libraryarea←"[SET,ME]"; ENDTOPS10
ochan←-1; no_output_yet←true;
for i←0 thru nfonts-1 do fontused[i]←false;
IFTENEX octaltime←gtad; ENDTENEX
IFSUAI octaltime←call(0,"ACCTIM"); ENDSUAI
ifc not (TENEX or SUAI) thenc 
	require "Must write code to initialize octaltime here!" message;
endc
end;

internal procedure declareofil(string s) # initializes the output on file s;
begin comment This procedure is called when the name of the output file is
first known. It opens the file and gets things started;
integer i;
ofilname←s;
define numdiskbuffers=⊂19⊃ # ignored under TENEX, by the way;
open(ochan←getchan,"DSK",8,0,numdiskbuffers,0,0,eof);
loop	begin enter(ochan,ofilname,eof);
	if eof then
		begin print(nextline,"I can't write on file ",ofilname);
		if not not_nonstop then quit;
		print(nextline,"Output file = ");
		ofilname←inchwl;
		end
	else done;
	end;
recnum←0;
bytecount←0;
pdptr←point(16, partdir[0], -1);
nparts←0;
DEBUGONLY for i←0 thru 1 do begin dlmaxused[i]←elmaxused[i]←0 end;
end;
comment General description of the shipout procedure.

The simplest imaginable shipout routine would essentially be a recursive
procedure that goes through the data structure of the given page and,
whenever coming to a character or rule node, it would cause that character or
rule to be output to the appropriate place depending on its context.
This routine would periodically issue commands to the output device,
saying "Put such-and-such a character (or rule) in such and such a place."

A simple routine of that sort won't work on the XGP, because the XGP server
needs to get its commands sorted in order of the top edges of the characters
and rules. Furthermore one should probably make use of the fact most of
TEX's output is simple text --  extra care can be taken to make the output
occur faster in simple cases.

Therefore this shipout procedure has been constructed by taking the
simple recursive scheme and augmenting it in two ways: On simple text,
most of the generality is omitted, and there is a sorting process that
takes place before actual output occurs to the XGP.

As we have seen, the XGP server gets its instructions in character mode,
so TEXOUT builds a file of 7-bit characters and control codes. Sequences
of 7-bit characters having the same y0-value (i.e., the same top edge
of the type) are generated and then sorted by y0.  A different sequence is
begun for every box and, within a box, every time a rule or sub-box appears,
or whenever a font change causes the value of y0 to change.

A further complication, of course, is that TEX computes everything as if it
had "infinite precision" while actual devices like the XGP have only finite
resolution. Rounding in this TEXOUT module is done by converting each
real-valued coordinate pair (x,y) into the integer-value discrete raster
position ([conv*x+.14159],[conv*y+.14159]). Here conv is the conversion factor
from points to XGP pixels, and .14159 is an arbitrary offset which makes it
unlikely that rounding discontinuities will occur at points with physical
significance.

The conversion factor conv used in this program is figured on the basis
that the Stanford XGP has 259.2 pixels per 72 points.  The XGP really has
200 pixels per inch, so TEX output is somewhat magnified. The reason for
doing this is that XGP output is intended to be used either for proofreading
(when larger type should enhance the readability) or for printing (when a
reduction factor of about 10/13 will improve the appearance of the
machine's rather low-resolution output). 

Instead of adding .14159 when rounding, this constant is actually absorbed
into the offsets which are routinely computed as the data structure is
being traversed -- all computation is done relative to some arbitrary
starting point, so the .14159/conv is simply included in this starting point.
;

comment Modifications for Press:
Since Press is intended to be a relatively device-independent representation,
positions are computed in micas (1 mica = 10 microns = 1/2540 inch) rather
than in pixels for some particular device. Fortunately, Press format does not
require objects to be sorted by position, so the press output routine can be
much closer to the "simplest imaginable shipout routine" described above.
Of course, there are complications...

The XGP's convention is that increasing y goes downward. The Press convention
is the opposite (increasing y upward). However, to avoid much error-prone
modification of the code, the y-downward convention is maintained, and y
is transformed only within the SetY procedure, assuming an 11-inch-high page.

What constitutes an "entity" in a page of TEX output is not clear. One view
would treat each TEX "box" as an entity, but this would entail an absurd amount
of overhead, since even single characters are packaged in individual boxes.
The extreme opposite view, adopted here, treats the entire page as one
very large entity. Actually, FOUR entity lists (and corresponding data lists)
are maintained, since four font sets are needed to accommodate 64 fonts.
To direct characters and commands to the proper entity requires some care.
;
comment The recursive traversal procedures: vlistout,hlistout;

forward recursive procedure hlistout(integer p; real x,y) # see below;

recursive procedure vlistout(integer p; real x,y);
begin comment This procedure generates instruction strings to output the
vlist box pointed to by p, where the upper left corner of the box is to
have coordinates (x,y);
comment N.B.: y is the TOP of the box!;
integer q # runs through the vlist;
integer m # mem[q];
real g # the glueset parameter for this box;
short integer x0,y0,h,w # units rounded to micas;
comment rounding from real to short integers is faster than to general integers;

q←value(p); g←glueset(p); x0←conv*x;
while q do
	begin case field(type,m←mem[q]) of begin
	[charnode] begin integer c,f,w;
	c←field(info,m); f←c lsh -7; w←fontinfo[c] # get character and font;
	fontused[f]←true # mark font "used";
	y←y+charht(f,w); y0←conv*y # baseline;
	comment Now (x0,y0) is reference point (in micas) where c should go;
	newfont(f); setpos(x0,y0); outchar(c) # DO NEWFONT FIRST! (may change en);
	y←y+chardp(f,w); end;
	[gluenode] begin integer r; r←field(value,m) # pointer to glue spec;
	if g=0 then y←y+gluespace(r)
	else if g>0 then y←y+gluespace(r)+gluestretch(r)*g
	else y←y+gluespace(r)+glueshrink(r)*g; end;
	[kernnode] y←y+gluespace(q);
	[rulenode] begin comment horizontal rule;
	y0←conv*y; h←roundup(height(q)+depth(q));
	if width(q)≤-100000.0 then w←roundup(width(p)) else w←roundup(width(q));
	outrule(x0,y0,h,w); y←y+height(q)+depth(q); end;
	[whatsitnode] voutext(q,x,y) # for extensions to TEX;
	[vlistnode] begin vlistout(q,x+shiftamt(q),y);
	y←y+height(q)+depth(q); end;
	[hlistnode] begin hlistout(q,x+shiftamt(q),y←y+height(q));
	y←y+depth(q); end;
	[leadernode] begin integer b; real hh;
	b←field(value,m) # pointer to box used for vertical leaders;
	if type(b)≠rulenode then
		begin hh←height(b)+depth(b); if hh<0 then hh←0;
		end
	else hh←-1.0;
	if hh≠0 and type(link(q))=gluenode then
		begin integer r; real s;
		q←link(q); r←value(q) # pointer to glue spec;
		if g=0 then s←gluespace(r)
		else if g>0 then s←gluespace(r)+gluestretch(r)*g
		else s←gluespace(r)+glueshrink(r)*g;
		if hh>0 then
			begin integer q # quotient; real yy # y surrogate;
			if shiftamt(b)=0 then
				begin q←y/hh-epsilon;
				yy←hh*(q+1) # the smallest suitable multiple of hh;
				end
			else	begin real r; q←s/hh; r←s-q*hh;
				if shiftamt(b)<0 then yy←y+r/2
				else	begin yy←y+r/(q+1); hh←hh+r/(q+1);
					end;
				end;
			comment hh is box size, yy is upper corner of top box;
			while yy+hh≤y+s+.1 do
				begin if type(b)=vlistnode then vlistout(b,x,yy)
				else hlistout(b,x,yy+height(b));
				yy←yy+hh;
				end;
			end
		else	begin comment variable vertical rule;
			w←roundup(width(b));y0←conv*y;h←roundup(s);
			outrule(x0,y0,h,w);
			end;
		y←y+s;
		end;
	end;
	else end # ignore all other types of nodes;
	q←link(q);
	end;
end;

recursive procedure hlistout(integer p; real x,y);
begin comment This procedure generates instruction strings to output the
hlist box pointed to by p, where the reference point of the box is to
have coordinates (x,y);
comment N.B.: y is the BASELINE!;
integer q # runs through the hlist;
integer m # mem[q];
real g # the glueset parameter for this box;
short integer x0,y0,h,w # coordinates rounded to micas;
comment rounding from real to short integers is faster than to general integers;

q←value(p); g←glueset(p); y0←conv*y;
while q do
	begin case field(type,m←mem[q]) of begin
	[charnode] begin comment This is a first character of a possibly long
	list, a common case which is "optimized" to keep the number of
	instruction strings reasonably small;
	integer c,f,w,h;
	c←field(info,m) # the extended character code;
	f←c lsh -7 # the font code;
	w←fontinfo[c] # the font information fields;
	fontused[f]←true # mark font "used";
	x0←conv*x # round to correct starting position;
	newfont(f) # must do this first - might switch entities!;
	setpos(x0,y0); outchar(c) # output c;
	x←x+charwd(f,w);
	while true do
		begin comment continue with same instruction stream
		as long as the nodes can be handled easily;
		integer f1 # font of new character;
		q←link(q);
		if q=0 then done;
		if field(type,m←mem[q])≠charnode then done;
		comment another charnode;
		c←field(info,m) # the extended character code;
		f1←c lsh -7 # the font code;
		comment must exit from loop if we switch font sets;
		if fontset(f1)≠fontset(f) then done;
		newfont(f←f1);
		w←fontinfo[c] # the font information fields;
		fontused[f]←true # mark font "used";
		outchar(c) # output the character;
		x←x+charwd(f,w);
		end;
	continue end # resume "while q" loop;
	[gluenode] begin integer r; r←field(value,m) # pointer to glue spec;
	if g=0 then x←x+gluespace(r)
	else if g>0 then x←x+gluespace(r)+gluestretch(r)*g
	else x←x+gluespace(r)+glueshrink(r)*g; end;
	[kernnode] x←x+gluespace(q);
	[rulenode] begin comment vertical rule; integer y00;
	if height(q)≤-100000.0 then height(q)←height(p); h←roundup(height(q));
	y00←y0-h+1; comment this way of calculating y00 means that the rule will
		stop at the baseline if the depth is zero;
	if depth(q)≤-100000.0 then depth(q)←depth(p); h←roundup(height(q)+depth(q));
	x0←conv*x; x←x+width(q); w←roundup(width(q));
	outrule(x0,y00,h,w); end;
	[whatsitnode] houtext(q,x,y) # for extensions to TEX;
	[vlistnode] begin vlistout(q,x,y-height(q)+shiftamt(q)); x←x+width(q); end;
	[hlistnode] begin hlistout(q,x,y+shiftamt(q)); x←x+width(q); end;
	[leadernode] begin integer b; real ww;
	b←field(value,m) # pointer to box used for horizontal leaders;
	if type(b)≠rulenode then
		begin ww←width(b); if ww<0 then ww←0;
		end
	else ww←-1.0;
	if ww≠0 and type(link(q))=gluenode then
		begin integer r; real s;
		q←link(q); r←value(q) # pointer to glue spec;
		if g=0 then s←gluespace(r)
		else if g>0 then s←gluespace(r)+gluestretch(r)*g
		else s←gluespace(r)+glueshrink(r)*g;
		if ww>0 then
			begin integer q # quotient; real xx # x surrogate;
			if shiftamt(b)=0 then
				begin q←x/ww-epsilon;
				xx←ww*(q+1) # the smallest suitable multiple of ww;
				end
			else	begin real r; q←s/ww; r←s-q*ww;
				if shiftamt(b)<0 then xx←x+r/2
				else	begin xx←x+r/(q+1); ww←ww+r/(q+1);
					end;
				end;
			comment ww is box size, xx is reference point of left box;
			while xx+ww≤x+s+.1 do
				begin if type(b)=hlistnode then hlistout(b,xx,y)
				else vlistout(b,xx,y-height(b));
				xx←xx+ww;
				end;
			end
		else	begin comment variable horizontal rule; short integer y00;
			h←roundup(height(b));y00←y0-h+1;
			h←roundup(height(b)+depth(b));
			w←roundup(s);x0←conv*x;
			outrule(x0,y00,h,w);
			end;
		x←x+s;
		end;
	end;
	else end # ignore other node types;
	q←link(q);
	end;
end;
internal procedure shipout(integer p) # the main output procedure,produces one page;
begin comment Parameter p points to a vlist box that is to be output;
integer i,padbytes, nextrec;

if ochan<0 then declareofil("TEXOUT"&ofilext) # make sure output file is open;

StartPage;
define inches(n)=⊂(micasPerInch*(n)+.14159)/conv⊃;
vlistout(p,inches(1),inches(1)) # prepare table of command strings;
comment the "inches(1)" here leaves an inch of margin for cases where the user
	has gone outside the box with negative glue;
no_output_yet←false;

comment pad data lists to multiples of 4 bytes;
for i←0 thru 3 do
	begin integer curbytepos,j,numtopad;
	en←i;
	Flush # don't forget to flush out pending characters!;
	curbytepos←dct[en] mod 4;
	if curbytepos=0 then continue;
	numtopad←4-curbytepos;
	for j←1 thru numtopad do DLByte(0);
	ELByte(ELSkipCharactersShort+numtopad-1);
	end;

comment write data lists;
Sout(dl0[0], dct[0]);
Sout(dl1[0], dct[1]);
Sout(dl2[0], dct[2]);
Sout(dl3[0], dct[3]);

comment construct entity trailers;
ETrailer(0, 0, dct[0]);
ETrailer(1, dct[0], dct[1]);
ETrailer(2, dct[1]+dct[0], dct[2]);
ETrailer(3, dct[2]+dct[1]+dct[0], dct[3]);

Wout(0) # zero word to mark beginning of entity lists;
Wout(0) # and another zero word to get back on double-word boundary;
comment write entity lists;
Sout(el0[0], ect[0]);
Sout(el1[0], ect[1]);
Sout(el2[0], ect[2]);
Sout(el3[0], ect[3]);
padbytes←PadRecord(ELNop);

nextrec←bytecount div 512;
AddPart(0, recnum, nextrec-recnum, padbytes div 2) # want WORDS of padding;
recnum←nextrec;

DEBUGONLY	for i←0 thru 3 do
DEBUGONLY		begin
DEBUGONLY		dlmaxused[i]←dlmaxused[i] max dct[i];
DEBUGONLY		elmaxused[i]←elmaxused[i] max ect[i];
DEBUGONLY		end;

end;
internal procedure closeout # just before TEX stops, do this;
begin integer n,f;
integer nextrec, pdlen, time, i;

if no_output_yet then
	begin print(nextline,"No output file."); return;
	end;

comment write the font directory part;
define entrylength=16 # in WORDS!!!;

for f←0 thru nfonts-1 do if (fontname[f] and fontused[f]) then
	begin 
	integer mcsize, firstchar, lastchar;
	mcsize←conv*fsize[f]+.5 # rounded size in micas;
	Wout(entrylength);
	Bout(fontset(f)) # font set;
	Bout(fontnum(f)) # font number within set;
	ifc PARC thenc
		if fpfb[f]<0 then begin firstchar←'200; lastchar←'377 end
		else begin firstchar←'000; lastchar←'177 end;
	elsec
		firstchar←'000; lastchar←'177;
	endc
	Bout(firstchar); Bout(lastchar);
	comment family name is a bcpl string, max 20 bytes;
	iBCPLout(f, 20);
	Bout(fpfb[f]) # face;
	Bout(firstchar) # "source" character;
	Wout(-mcsize);
	Wout(0) # rotation;
	end;
Wout(0) # a zero word to mark the end of the font directory!;
PadRecord(0);
nextrec←bytecount div 512;
AddPart(1, recnum, nextrec-recnum);
recnum←nextrec;

comment write the part directory;
pdlen←8*nparts # 4 words (8 bytes) per part;
Sout(partdir[0], pdlen);
PadRecord(0);
nextrec←bytecount div 512;

comment now, finally, the document directory;
Wout(27183) # general password;
Wout(nextrec+1) # total number of records in file (including this one);
Wout(nparts) # number of parts;
Wout(recnum) # start of part dir;
Wout(nextrec-recnum) # number of records in part dir;
Wout(-1) # back-pointer to obsolete document directory(?);
Dout(altotime) # machine-style date/time stamp;
Wout(1); Wout(1) # first and last copy;
for i←10 thru '177 do Wout(-1);
sBCPLout(ofilname, 2*26);
sBCPLout(username, 2*16) # user's name for break page of document;
sBCPLout(daytime, 2*20) # string date and time for break page as well;
PadRecord(0);

ifc TENEX thenc
comment When we release the channel, we must utter subtle magic incantations
	to convince TENEX that this file really is a sequence of 8 bit bytes,
	rather than 36-bit bytes (the way we wrote it!);
	begin
	integer fllen # file length;
	integer array fdb[0:'24] # file descriptor block;
	closf(ochan);
	gtfdb(ochan, fdb);
	fllen←fdb['12];
	comment change byte size from 36 to 8;
	chfdb(ochan, '11, (2↑6-1) lsh 24, 8 lsh 24);
	comment and multiply EOF byte count by 4 to compensate;
	chfdb(ochan, '12, -1, 4*fllen);	
	rljfn(ochan);
	end;
elsec
release(ochan);
IFSUAI ptostr(0,"dover "&ofilname&"/q") # suggest file spooling to user; ENDSUAI
endc
end;
end